home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / 1.6.0 / ice-9 / test.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  29.2 KB  |  1,032 lines
  1. ;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
  2. ;; 
  3. ;; This program is free software; you can redistribute it and/or modify
  4. ;; it under the terms of the GNU General Public License as published by
  5. ;; the Free Software Foundation; either version 2, or (at your option)
  6. ;; any later version.
  7. ;; 
  8. ;; This program is distributed in the hope that it will be useful,
  9. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;; GNU General Public License for more details.
  12. ;; 
  13. ;; You should have received a copy of the GNU General Public License
  14. ;; along with this software; see the file COPYING.  If not, write to
  15. ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16. ;; Boston, MA 02111-1307 USA
  17. ;;
  18. ;; As a special exception, the Free Software Foundation gives permission
  19. ;; for additional uses of the text contained in its release of GUILE.
  20. ;;
  21. ;; The exception is that, if you link the GUILE library with other files
  22. ;; to produce an executable, this does not by itself cause the
  23. ;; resulting executable to be covered by the GNU General Public License.
  24. ;; Your use of that executable is in no way restricted on account of
  25. ;; linking the GUILE library code into it.
  26. ;;
  27. ;; This exception does not however invalidate any other reasons why
  28. ;; the executable file might be covered by the GNU General Public License.
  29. ;;
  30. ;; This exception applies only to the code released by the
  31. ;; Free Software Foundation under the name GUILE.  If you copy
  32. ;; code from other Free Software Foundation releases into a copy of
  33. ;; GUILE, as the General Public License permits, the exception does
  34. ;; not apply to the code that you add in this way.  To avoid misleading
  35. ;; anyone as to the status of such modified files, you must delete
  36. ;; this exception notice from them.
  37. ;;
  38. ;; If you write modifications of your own for GUILE, it is your choice
  39. ;; whether to permit this exception to apply to your modifications.
  40. ;; If you do not wish that, delete this exception notice.  
  41.  
  42. ;;;; "test.scm" Test correctness of scheme implementations.
  43. ;;; Author: Aubrey Jaffer
  44. ;;; Modified: Mikael Djurfeldt (Removed tests which Guile deliberately
  45. ;;; won't pass.  Made the the tests (test-cont), (test-sc4), and
  46. ;;; (test-delay) start to run automatically.
  47.  
  48. ;;; This includes examples from
  49. ;;; William Clinger and Jonathan Rees, editors.
  50. ;;; Revised^4 Report on the Algorithmic Language Scheme
  51. ;;; and the IEEE specification.
  52.  
  53. ;;; The input tests read this file expecting it to be named
  54. ;;; "test.scm", so you'll have to run it from the ice-9 source
  55. ;;; directory, or copy this file elsewhere
  56. ;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
  57. ;;; these tests.  You may need to delete them in order to run
  58. ;;; "test.scm" more than once.
  59.  
  60. ;;;   There are three optional tests:
  61. ;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
  62. ;;; 
  63. ;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
  64. ;;; 
  65. ;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
  66. ;;;   either standard.
  67.  
  68. ;;; If you are testing a R3RS version which does not have `list?' do:
  69. ;;; (define list? #f)
  70.  
  71. ;;; send corrections or additions to jaffer@ai.mit.edu or
  72. ;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA
  73.  
  74. (define cur-section '())(define errs '())
  75. (define SECTION (lambda args
  76.           (display "SECTION") (write args) (newline)
  77.           (set! cur-section args) #t))
  78. (define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
  79.  
  80. (define test
  81.   (lambda (expect fun . args)
  82.     (write (cons fun args))
  83.     (display "  ==> ")
  84.     ((lambda (res)
  85.       (write res)
  86.       (newline)
  87.       (cond ((not (equal? expect res))
  88.          (record-error (list res expect (cons fun args)))
  89.          (display " BUT EXPECTED ")
  90.          (write expect)
  91.          (newline)
  92.          #f)
  93.         (else #t)))
  94.      (if (procedure? fun) (apply fun args) (car args)))))
  95. (define (report-errs)
  96.   (newline)
  97.   (if (null? errs) (display "Passed all tests")
  98.       (begin
  99.     (display "errors were:")
  100.     (newline)
  101.     (display "(SECTION (got expected (call)))")
  102.     (newline)
  103.     (for-each (lambda (l) (write l) (newline))
  104.           errs)))
  105.   (newline))
  106.  
  107. (SECTION 2 1);; test that all symbol characters are supported.
  108. '(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
  109.  
  110. (SECTION 3 4)
  111. (define disjoint-type-functions
  112.   (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
  113. (define type-examples
  114.   (list
  115.    #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
  116. (define i 1)
  117. (for-each (lambda (x) (display (make-string i #\ ))
  118.           (set! i (+ 3 i))
  119.           (write x)
  120.           (newline))
  121.       disjoint-type-functions)
  122. (define type-matrix
  123.   (map (lambda (x)
  124.      (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
  125.        (write t)
  126.        (write x)
  127.        (newline)
  128.        t))
  129.        type-examples))
  130. (SECTION 4 1 2)
  131. (test '(quote a) 'quote (quote 'a))
  132. (test '(quote a) 'quote ''a)
  133. (SECTION 4 1 3)
  134. (test 12 (if #f + *) 3 4)
  135. (SECTION 4 1 4)
  136. (test 8 (lambda (x) (+ x x)) 4)
  137. (define reverse-subtract
  138.   (lambda (x y) (- y x)))
  139. (test 3 reverse-subtract 7 10)
  140. (define add4
  141.   (let ((x 4))
  142.     (lambda (y) (+ x y))))
  143. (test 10 add4 6)
  144. (test '(3 4 5 6) (lambda x x) 3 4 5 6)
  145. (test '(5 6) (lambda (x y . z) z) 3 4 5 6)
  146. (SECTION 4 1 5)
  147. (test 'yes 'if (if (> 3 2) 'yes 'no))
  148. (test 'no 'if (if (> 2 3) 'yes 'no))
  149. (test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
  150. (SECTION 4 1 6)
  151. (define x 2)
  152. (test 3 'define (+ x 1))
  153. (set! x 4)
  154. (test 5 'set! (+ x 1))
  155. (SECTION 4 2 1)
  156. (test 'greater 'cond (cond ((> 3 2) 'greater)
  157.                ((< 3 2) 'less)))
  158. (test 'equal 'cond (cond ((> 3 3) 'greater)
  159.              ((< 3 3) 'less)
  160.              (else 'equal)))
  161. (test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
  162.              (else #f)))
  163. (test 'composite 'case (case (* 2 3)
  164.              ((2 3 5 7) 'prime)
  165.              ((1 4 6 8 9) 'composite)))
  166. (test 'consonant 'case (case (car '(c d))
  167.              ((a e i o u) 'vowel)
  168.              ((w y) 'semivowel)
  169.              (else 'consonant)))
  170. (test #t 'and (and (= 2 2) (> 2 1)))
  171. (test #f 'and (and (= 2 2) (< 2 1)))
  172. (test '(f g) 'and (and 1 2 'c '(f g)))
  173. (test #t 'and (and))
  174. (test #t 'or (or (= 2 2) (> 2 1)))
  175. (test #t 'or (or (= 2 2) (< 2 1)))
  176. (test #f 'or (or #f #f #f))
  177. (test #f 'or (or))
  178. (test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
  179. (SECTION 4 2 2)
  180. (test 6 'let (let ((x 2) (y 3)) (* x y)))
  181. (test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
  182. (test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
  183. (test #t 'letrec (letrec ((even?
  184.                (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
  185.               (odd?
  186.                (lambda (n) (if (zero? n) #f (even? (- n 1))))))
  187.            (even? 88)))
  188. (define x 34)
  189. (test 5 'let (let ((x 3)) (define x 5) x))
  190. (test 34 'let x)
  191. (test 6 'let (let () (define x 6) x))
  192. (test 34 'let x)
  193. (test 7 'let* (let* ((x 3)) (define x 7) x))
  194. (test 34 'let* x)
  195. (test 8 'let* (let* () (define x 8) x))
  196. (test 34 'let* x)
  197. (test 9 'letrec (letrec () (define x 9) x))
  198. (test 34 'letrec x)
  199. (test 10 'letrec (letrec ((x 3)) (define x 10) x))
  200. (test 34 'letrec x)
  201. (SECTION 4 2 3)
  202. (define x 0)
  203. (test 6 'begin (begin (set! x 5) (+ x 1)))
  204. (SECTION 4 2 4)
  205. (test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
  206.                 (i 0 (+ i 1)))
  207.                ((= i 5) vec)
  208.              (vector-set! vec i i)))
  209. (test 25 'do (let ((x '(1 3 5 7 9)))
  210.            (do ((x x (cdr x))
  211.             (sum 0 (+ sum (car x))))
  212.            ((null? x) sum))))
  213. (test 1 'let (let foo () 1))
  214. (test '((6 1 3) (-5 -2)) 'let
  215.       (let loop ((numbers '(3 -2 1 6 -5))
  216.          (nonneg '())
  217.          (neg '()))
  218.     (cond ((null? numbers) (list nonneg neg))
  219.           ((negative? (car numbers))
  220.            (loop (cdr numbers)
  221.              nonneg
  222.              (cons (car numbers) neg)))
  223.           (else
  224.            (loop (cdr numbers)
  225.              (cons (car numbers) nonneg)
  226.              neg)))))
  227. (SECTION 4 2 6)
  228. (test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
  229. (test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
  230. (test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
  231. (test '((foo 7) . cons)
  232.     'quasiquote
  233.     `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
  234.  
  235. ;;; sqt is defined here because not all implementations are required to
  236. ;;; support it. 
  237. (define (sqt x)
  238.     (do ((i 0 (+ i 1)))
  239.         ((> (* i i) x) (- i 1))))
  240.  
  241. (test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
  242. (test 5 'quasiquote `,(+ 2 3))
  243. (test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
  244.       'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
  245. (test '(a `(b ,x ,'y d) e) 'quasiquote
  246.     (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
  247. (test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
  248. (test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
  249. (SECTION 5 2 1)
  250. (define add3 (lambda (x) (+ x 3)))
  251. (test 6 'define (add3 3))
  252. (define first car)
  253. (test 1 'define (first '(1 2)))
  254. (SECTION 5 2 2)
  255. (test 45 'define
  256.     (let ((x 5))
  257.         (define foo (lambda (y) (bar x y)))
  258.         (define bar (lambda (a b) (+ (* a b) a)))
  259.         (foo (+ x 3))))
  260. (define x 34)
  261. (define (foo) (define x 5) x)
  262. (test 5 foo)
  263. (test 34 'define x)
  264. (define foo (lambda () (define x 5) x))
  265. (test 5 foo)
  266. (test 34 'define x)
  267. (define (foo x) ((lambda () (define x 5) x)) x)
  268. (test 88 foo 88)
  269. (test 4 foo 4)
  270. (test 34 'define x)
  271. (SECTION 6 1)
  272. (test #f not #t)
  273. (test #f not 3)
  274. (test #f not (list 3))
  275. (test #t not #f)
  276. (test #f not '())
  277. (test #f not (list))
  278. (test #f not 'nil)
  279.  
  280. (test #t boolean? #f)
  281. (test #f boolean? 0)
  282. (test #f boolean? '())
  283. (SECTION 6 2)
  284. (test #t eqv? 'a 'a)
  285. (test #f eqv? 'a 'b)
  286. (test #t eqv? 2 2)
  287. (test #t eqv? '() '())
  288. (test #t eqv? '10000 '10000)
  289. (test #f eqv? (cons 1 2)(cons 1 2))
  290. (test #f eqv? (lambda () 1) (lambda () 2))
  291. (test #f eqv? #f 'nil)
  292. (let ((p (lambda (x) x)))
  293.   (test #t eqv? p p))
  294. (define gen-counter
  295.  (lambda ()
  296.    (let ((n 0))
  297.       (lambda () (set! n (+ n 1)) n))))
  298. (let ((g (gen-counter))) (test #t eqv? g g))
  299. (test #f eqv? (gen-counter) (gen-counter))
  300. (letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
  301.      (g (lambda () (if (eqv? f g) 'g 'both))))
  302.   (test #f eqv? f g))
  303.  
  304. (test #t eq? 'a 'a)
  305. (test #f eq? (list 'a) (list 'a))
  306. (test #t eq? '() '())
  307. (test #t eq? car car)
  308. (let ((x '(a))) (test #t eq? x x))
  309. (let ((x '#())) (test #t eq? x x))
  310. (let ((x (lambda (x) x))) (test #t eq? x x))
  311.  
  312. (test #t equal? 'a 'a)
  313. (test #t equal? '(a) '(a))
  314. (test #t equal? '(a (b) c) '(a (b) c))
  315. (test #t equal? "abc" "abc")
  316. (test #t equal? 2 2)
  317. (test #t equal? (make-vector 5 'a) (make-vector 5 'a))
  318. (SECTION 6 3)
  319. (test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
  320. (define x (list 'a 'b 'c))
  321. (define y x)
  322. (and list? (test #t list? y))
  323. (set-cdr! x 4)
  324. (test '(a . 4) 'set-cdr! x)
  325. (test #t eqv? x y)
  326. (test '(a b c . d) 'dot '(a . (b . (c . d))))
  327. (and list? (test #f list? y))
  328. (and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
  329.  
  330. (test #t pair? '(a . b))
  331. (test #t pair? '(a . 1))
  332. (test #t pair? '(a b c))
  333. (test #f pair? '())
  334. (test #f pair? '#(a b))
  335.  
  336. (test '(a) cons 'a '())
  337. (test '((a) b c d) cons '(a) '(b c d))
  338. (test '("a" b c) cons "a" '(b c))
  339. (test '(a . 3) cons 'a 3)
  340. (test '((a b) . c) cons '(a b) 'c)
  341.  
  342. (test 'a car '(a b c))
  343. (test '(a) car '((a) b c d))
  344. (test 1 car '(1 . 2))
  345.  
  346. (test '(b c d) cdr '((a) b c d))
  347. (test 2 cdr '(1 . 2))
  348.  
  349. (test '(a 7 c) list 'a (+ 3 4) 'c)
  350. (test '() list)
  351.  
  352. (test 3 length '(a b c))
  353. (test 3 length '(a (b) (c d e)))
  354. (test 0 length '())
  355.  
  356. (test '(x y) append '(x) '(y))
  357. (test '(a b c d) append '(a) '(b c d))
  358. (test '(a (b) (c)) append '(a (b)) '((c)))
  359. (test '() append)
  360. (test '(a b c . d) append '(a b) '(c . d))
  361. (test 'a append '() 'a)
  362.  
  363. (test '(c b a) reverse '(a b c))
  364. (test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
  365.  
  366. (test 'c list-ref '(a b c d) 2)
  367.  
  368. (test '(a b c) memq 'a '(a b c))
  369. (test '(b c) memq 'b '(a b c))
  370. (test '#f memq 'a '(b c d))
  371. (test '#f memq (list 'a) '(b (a) c))
  372. (test '((a) c) member (list 'a) '(b (a) c))
  373. (test '(101 102) memv 101 '(100 101 102))
  374.  
  375. (define e '((a 1) (b 2) (c 3)))
  376. (test '(a 1) assq 'a e)
  377. (test '(b 2) assq 'b e)
  378. (test #f assq 'd e)
  379. (test #f assq (list 'a) '(((a)) ((b)) ((c))))
  380. (test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
  381. (test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
  382. (SECTION 6 4)
  383. (test #t symbol? 'foo)
  384. (test #t symbol? (car '(a b)))
  385. (test #f symbol? "bar")
  386. (test #t symbol? 'nil)
  387. (test #f symbol? '())
  388. (test #f symbol? #f)
  389. ;;; But first, what case are symbols in?  Determine the standard case:
  390. (define char-standard-case char-upcase)
  391. (if (string=? (symbol->string 'A) "a")
  392.     (set! char-standard-case char-downcase))
  393. ;;; Not for Guile
  394. ;(test #t 'standard-case
  395. ;      (string=? (symbol->string 'a) (symbol->string 'A)))
  396. ;(test #t 'standard-case
  397. ;      (or (string=? (symbol->string 'a) "A")
  398. ;      (string=? (symbol->string 'A) "a")))
  399. (define (str-copy s)
  400.   (let ((v (make-string (string-length s))))
  401.     (do ((i (- (string-length v) 1) (- i 1)))
  402.     ((< i 0) v)
  403.       (string-set! v i (string-ref s i)))))
  404. (define (string-standard-case s)
  405.   (set! s (str-copy s))
  406.   (do ((i 0 (+ 1 i))
  407.        (sl (string-length s)))
  408.       ((>= i sl) s)
  409.       (string-set! s i (char-standard-case (string-ref s i)))))
  410. ;;; Not for Guile
  411. ;(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
  412. ;(test (string-standard-case "martin") symbol->string 'Martin)
  413. (test "Malvina" symbol->string (string->symbol "Malvina"))
  414. ;;; Not for Guile
  415. ;(test #t 'standard-case (eq? 'a 'A))
  416.  
  417. (define x (string #\a #\b))
  418. (define y (string->symbol x))
  419. (string-set! x 0 #\c)
  420. (test "cb" 'string-set! x)
  421. (test "ab" symbol->string y)
  422. (test y string->symbol "ab")
  423.  
  424. ;;; Not for Guile
  425. ;(test #t eq? 'mISSISSIppi 'mississippi)
  426. ;(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
  427. (test 'JollyWog string->symbol (symbol->string 'JollyWog))
  428.  
  429. (SECTION 6 5 5)
  430. (test #t number? 3)
  431. (test #t complex? 3)
  432. (test #t real? 3)
  433. (test #t rational? 3)
  434. (test #t integer? 3)
  435.  
  436. (test #t exact? 3)
  437. (test #f inexact? 3)
  438.  
  439. (test #t = 22 22 22)
  440. (test #t = 22 22)
  441. (test #f = 34 34 35)
  442. (test #f = 34 35)
  443. (test #t > 3 -6246)
  444. (test #f > 9 9 -2424)
  445. (test #t >= 3 -4 -6246)
  446. (test #t >= 9 9)
  447. (test #f >= 8 9)
  448. (test #t < -1 2 3 4 5 6 7 8)
  449. (test #f < -1 2 3 4 4 5 6 7)
  450. (test #t <= -1 2 3 4 5 6 7 8)
  451. (test #t <= -1 2 3 4 4 5 6 7)
  452. (test #f < 1 3 2)
  453. (test #f >= 1 3 2)
  454.  
  455. (test #t zero? 0)
  456. (test #f zero? 1)
  457. (test #f zero? -1)
  458. (test #f zero? -100)
  459. (test #t positive? 4)
  460. (test #f positive? -4)
  461. (test #f positive? 0)
  462. (test #f negative? 4)
  463. (test #t negative? -4)
  464. (test #f negative? 0)
  465. (test #t odd? 3)
  466. (test #f odd? 2)
  467. (test #f odd? -4)
  468. (test #t odd? -1)
  469. (test #f even? 3)
  470. (test #t even? 2)
  471. (test #t even? -4)
  472. (test #f even? -1)
  473.  
  474. (test 38 max 34 5 7 38 6)
  475. (test -24 min 3  5 5 330 4 -24)
  476.  
  477. (test 7 + 3 4)
  478. (test '3 + 3)
  479. (test 0 +)
  480. (test 4 * 4)
  481. (test 1 *)
  482.  
  483. (test -1 - 3 4)
  484. (test -3 - 3)
  485. (test 7 abs -7)
  486. (test 7 abs 7)
  487. (test 0 abs 0)
  488.  
  489. (test 5 quotient 35 7)
  490. (test -5 quotient -35 7)
  491. (test -5 quotient 35 -7)
  492. (test 5 quotient -35 -7)
  493. (test 1 modulo 13 4)
  494. (test 1 remainder 13 4)
  495. (test 3 modulo -13 4)
  496. (test -1 remainder -13 4)
  497. (test -3 modulo 13 -4)
  498. (test 1 remainder 13 -4)
  499. (test -1 modulo -13 -4)
  500. (test -1 remainder -13 -4)
  501. (define (divtest n1 n2)
  502.     (= n1 (+ (* n2 (quotient n1 n2))
  503.          (remainder n1 n2))))
  504. (test #t divtest 238 9)
  505. (test #t divtest -238 9)
  506. (test #t divtest 238 -9)
  507. (test #t divtest -238 -9)
  508.  
  509. (test 4 gcd 0 4)
  510. (test 4 gcd -4 0)
  511. (test 4 gcd 32 -36)
  512. (test 0 gcd)
  513. (test 288 lcm 32 -36)
  514. (test 1 lcm)
  515.  
  516. ;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
  517. ;;; Modified by jaffer.
  518. (define (test-inexact)
  519.   (define f3.9 (string->number "3.9"))
  520.   (define f4.0 (string->number "4.0"))
  521.   (define f-3.25 (string->number "-3.25"))
  522.   (define f.25 (string->number ".25"))
  523.   (define f4.5 (string->number "4.5"))
  524.   (define f3.5 (string->number "3.5"))
  525.   (define f0.0 (string->number "0.0"))
  526.   (define f0.8 (string->number "0.8"))
  527.   (define f1.0 (string->number "1.0"))
  528.   (define wto write-test-obj)
  529.   (define dto display-test-obj)
  530.   (define lto load-test-obj)
  531.   (newline)
  532.   (display ";testing inexact numbers; ")
  533.   (newline)
  534.   (SECTION 6 5 5)
  535.   (test #t inexact? f3.9)
  536.   (test #t 'inexact? (inexact? (max f3.9 4)))
  537.   (test f4.0 'max (max f3.9 4))
  538.   (test f4.0 'exact->inexact (exact->inexact 4))
  539.   (test (- f4.0) round (- f4.5))
  540.   (test (- f4.0) round (- f3.5))
  541.   (test (- f4.0) round (- f3.9))
  542.   (test f0.0 round f0.0)
  543.   (test f0.0 round f.25)
  544.   (test f1.0 round f0.8)
  545.   (test f4.0 round f3.5)
  546.   (test f4.0 round f4.5)
  547.   (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
  548.   (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
  549.   (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
  550.   (test #t call-with-output-file
  551.       "tmp3"
  552.       (lambda (test-file)
  553.     (write-char #\; test-file)
  554.     (display write-test-obj test-file)
  555.     (newline test-file)
  556.     (write load-test-obj test-file)
  557.     (output-port? test-file)))
  558.   (check-test-file "tmp3")
  559.   (set! write-test-obj wto)
  560.   (set! display-test-obj dto)
  561.   (set! load-test-obj lto)
  562.   (let ((x (string->number "4195835.0"))
  563.     (y (string->number "3145727.0")))
  564.     (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
  565.   (report-errs))
  566.  
  567. (define (test-bignum)
  568.   (define tb
  569.     (lambda (n1 n2)
  570.       (= n1 (+ (* n2 (quotient n1 n2))
  571.            (remainder n1 n2)))))
  572.   (newline)
  573.   (display ";testing bignums; ")
  574.   (newline)
  575.   (SECTION 6 5 5)
  576.   (test 0 modulo -2177452800 86400)
  577.   (test 0 modulo 2177452800 -86400)
  578.   (test 0 modulo 2177452800 86400)
  579.   (test 0 modulo -2177452800 -86400)
  580.   (test #t 'remainder (tb 281474976710655 65535))
  581.   (test #t 'remainder (tb 281474976710654 65535))
  582.   (SECTION 6 5 6)
  583.   (test 281474976710655 string->number "281474976710655")
  584.   (test "281474976710655" number->string 281474976710655)
  585.   (report-errs))
  586.  
  587. (SECTION 6 5 6)
  588. (test "0" number->string 0)
  589. (test "100" number->string 100)
  590. (test "100" number->string 256 16)
  591. (test 100 string->number "100")
  592. (test 256 string->number "100" 16)
  593. (test #f string->number "")
  594. (test #f string->number ".")
  595. (test #f string->number "d")
  596. (test #f string->number "D")
  597. (test #f string->number "i")
  598. (test #f string->number "I")
  599. (test #f string->number "3i")
  600. (test #f string->number "3I")
  601. (test #f string->number "33i")
  602. (test #f string->number "33I")
  603. (test #f string->number "3.3i")
  604. (test #f string->number "3.3I")
  605. (test #f string->number "-")
  606. (test #f string->number "+")
  607.  
  608. (SECTION 6 6)
  609. (test #t eqv? '#\  #\Space)
  610. (test #t eqv? #\space '#\Space)
  611. (test #t char? #\a)
  612. (test #t char? #\()
  613. (test #t char? #\ )
  614. (test #t char? '#\newline)
  615.  
  616. (test #f char=? #\A #\B)
  617. (test #f char=? #\a #\b)
  618. (test #f char=? #\9 #\0)
  619. (test #t char=? #\A #\A)
  620.  
  621. (test #t char<? #\A #\B)
  622. (test #t char<? #\a #\b)
  623. (test #f char<? #\9 #\0)
  624. (test #f char<? #\A #\A)
  625.  
  626. (test #f char>? #\A #\B)
  627. (test #f char>? #\a #\b)
  628. (test #t char>? #\9 #\0)
  629. (test #f char>? #\A #\A)
  630.  
  631. (test #t char<=? #\A #\B)
  632. (test #t char<=? #\a #\b)
  633. (test #f char<=? #\9 #\0)
  634. (test #t char<=? #\A #\A)
  635.  
  636. (test #f char>=? #\A #\B)
  637. (test #f char>=? #\a #\b)
  638. (test #t char>=? #\9 #\0)
  639. (test #t char>=? #\A #\A)
  640.  
  641. (test #f char-ci=? #\A #\B)
  642. (test #f char-ci=? #\a #\B)
  643. (test #f char-ci=? #\A #\b)
  644. (test #f char-ci=? #\a #\b)
  645. (test #f char-ci=? #\9 #\0)
  646. (test #t char-ci=? #\A #\A)
  647. (test #t char-ci=? #\A #\a)
  648.  
  649. (test #t char-ci<? #\A #\B)
  650. (test #t char-ci<? #\a #\B)
  651. (test #t char-ci<? #\A #\b)
  652. (test #t char-ci<? #\a #\b)
  653. (test #f char-ci<? #\9 #\0)
  654. (test #f char-ci<? #\A #\A)
  655. (test #f char-ci<? #\A #\a)
  656.  
  657. (test #f char-ci>? #\A #\B)
  658. (test #f char-ci>? #\a #\B)
  659. (test #f char-ci>? #\A #\b)
  660. (test #f char-ci>? #\a #\b)
  661. (test #t char-ci>? #\9 #\0)
  662. (test #f char-ci>? #\A #\A)
  663. (test #f char-ci>? #\A #\a)
  664.  
  665. (test #t char-ci<=? #\A #\B)
  666. (test #t char-ci<=? #\a #\B)
  667. (test #t char-ci<=? #\A #\b)
  668. (test #t char-ci<=? #\a #\b)
  669. (test #f char-ci<=? #\9 #\0)
  670. (test #t char-ci<=? #\A #\A)
  671. (test #t char-ci<=? #\A #\a)
  672.  
  673. (test #f char-ci>=? #\A #\B)
  674. (test #f char-ci>=? #\a #\B)
  675. (test #f char-ci>=? #\A #\b)
  676. (test #f char-ci>=? #\a #\b)
  677. (test #t char-ci>=? #\9 #\0)
  678. (test #t char-ci>=? #\A #\A)
  679. (test #t char-ci>=? #\A #\a)
  680.  
  681. (test #t char-alphabetic? #\a)
  682. (test #t char-alphabetic? #\A)
  683. (test #t char-alphabetic? #\z)
  684. (test #t char-alphabetic? #\Z)
  685. (test #f char-alphabetic? #\0)
  686. (test #f char-alphabetic? #\9)
  687. (test #f char-alphabetic? #\space)
  688. (test #f char-alphabetic? #\;)
  689.  
  690. (test #f char-numeric? #\a)
  691. (test #f char-numeric? #\A)
  692. (test #f char-numeric? #\z)
  693. (test #f char-numeric? #\Z)
  694. (test #t char-numeric? #\0)
  695. (test #t char-numeric? #\9)
  696. (test #f char-numeric? #\space)
  697. (test #f char-numeric? #\;)
  698.  
  699. (test #f char-whitespace? #\a)
  700. (test #f char-whitespace? #\A)
  701. (test #f char-whitespace? #\z)
  702. (test #f char-whitespace? #\Z)
  703. (test #f char-whitespace? #\0)
  704. (test #f char-whitespace? #\9)
  705. (test #t char-whitespace? #\space)
  706. (test #f char-whitespace? #\;)
  707.  
  708. (test #f char-upper-case? #\0)
  709. (test #f char-upper-case? #\9)
  710. (test #f char-upper-case? #\space)
  711. (test #f char-upper-case? #\;)
  712.  
  713. (test #f char-lower-case? #\0)
  714. (test #f char-lower-case? #\9)
  715. (test #f char-lower-case? #\space)
  716. (test #f char-lower-case? #\;)
  717.  
  718. (test #\. integer->char (char->integer #\.))
  719. (test #\A integer->char (char->integer #\A))
  720. (test #\a integer->char (char->integer #\a))
  721. (test #\A char-upcase #\A)
  722. (test #\A char-upcase #\a)
  723. (test #\a char-downcase #\A)
  724. (test #\a char-downcase #\a)
  725. (SECTION 6 7)
  726. (test #t string? "The word \"recursion\\\" has many meanings.")
  727. (test #t string? "")
  728. (define f (make-string 3 #\*))
  729. (test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
  730. (test "abc" string #\a #\b #\c)
  731. (test "" string)
  732. (test 3 string-length "abc")
  733. (test #\a string-ref "abc" 0)
  734. (test #\c string-ref "abc" 2)
  735. (test 0 string-length "")
  736. (test "" substring "ab" 0 0)
  737. (test "" substring "ab" 1 1)
  738. (test "" substring "ab" 2 2)
  739. (test "a" substring "ab" 0 1)
  740. (test "b" substring "ab" 1 2)
  741. (test "ab" substring "ab" 0 2)
  742. (test "foobar" string-append "foo" "bar")
  743. (test "foo" string-append "foo")
  744. (test "foo" string-append "foo" "")
  745. (test "foo" string-append "" "foo")
  746. (test "" string-append)
  747. (test "" make-string 0)
  748. (test #t string=? "" "")
  749. (test #f string<? "" "")
  750. (test #f string>? "" "")
  751. (test #t string<=? "" "")
  752. (test #t string>=? "" "")
  753. (test #t string-ci=? "" "")
  754. (test #f string-ci<? "" "")
  755. (test #f string-ci>? "" "")
  756. (test #t string-ci<=? "" "")
  757. (test #t string-ci>=? "" "")
  758.  
  759. (test #f string=? "A" "B")
  760. (test #f string=? "a" "b")
  761. (test #f string=? "9" "0")
  762. (test #t string=? "A" "A")
  763.  
  764. (test #t string<? "A" "B")
  765. (test #t string<? "a" "b")
  766. (test #f string<? "9" "0")
  767. (test #f string<? "A" "A")
  768.  
  769. (test #f string>? "A" "B")
  770. (test #f string>? "a" "b")
  771. (test #t string>? "9" "0")
  772. (test #f string>? "A" "A")
  773.  
  774. (test #t string<=? "A" "B")
  775. (test #t string<=? "a" "b")
  776. (test #f string<=? "9" "0")
  777. (test #t string<=? "A" "A")
  778.  
  779. (test #f string>=? "A" "B")
  780. (test #f string>=? "a" "b")
  781. (test #t string>=? "9" "0")
  782. (test #t string>=? "A" "A")
  783.  
  784. (test #f string-ci=? "A" "B")
  785. (test #f string-ci=? "a" "B")
  786. (test #f string-ci=? "A" "b")
  787. (test #f string-ci=? "a" "b")
  788. (test #f string-ci=? "9" "0")
  789. (test #t string-ci=? "A" "A")
  790. (test #t string-ci=? "A" "a")
  791.  
  792. (test #t string-ci<? "A" "B")
  793. (test #t string-ci<? "a" "B")
  794. (test #t string-ci<? "A" "b")
  795. (test #t string-ci<? "a" "b")
  796. (test #f string-ci<? "9" "0")
  797. (test #f string-ci<? "A" "A")
  798. (test #f string-ci<? "A" "a")
  799.  
  800. (test #f string-ci>? "A" "B")
  801. (test #f string-ci>? "a" "B")
  802. (test #f string-ci>? "A" "b")
  803. (test #f string-ci>? "a" "b")
  804. (test #t string-ci>? "9" "0")
  805. (test #f string-ci>? "A" "A")
  806. (test #f string-ci>? "A" "a")
  807.  
  808. (test #t string-ci<=? "A" "B")
  809. (test #t string-ci<=? "a" "B")
  810. (test #t string-ci<=? "A" "b")
  811. (test #t string-ci<=? "a" "b")
  812. (test #f string-ci<=? "9" "0")
  813. (test #t string-ci<=? "A" "A")
  814. (test #t string-ci<=? "A" "a")
  815.  
  816. (test #f string-ci>=? "A" "B")
  817. (test #f string-ci>=? "a" "B")
  818. (test #f string-ci>=? "A" "b")
  819. (test #f string-ci>=? "a" "b")
  820. (test #t string-ci>=? "9" "0")
  821. (test #t string-ci>=? "A" "A")
  822. (test #t string-ci>=? "A" "a")
  823. (SECTION 6 8)
  824. (test #t vector? '#(0 (2 2 2 2) "Anna"))
  825. (test #t vector? '#())
  826. (test '#(a b c) vector 'a 'b 'c)
  827. (test '#() vector)
  828. (test 3 vector-length '#(0 (2 2 2 2) "Anna"))
  829. (test 0 vector-length '#())
  830. (test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
  831. (test '#(0 ("Sue" "Sue") "Anna") 'vector-set
  832.     (let ((vec (vector 0 '(2 2 2 2) "Anna")))
  833.       (vector-set! vec 1 '("Sue" "Sue"))
  834.       vec))
  835. (test '#(hi hi) make-vector 2 'hi)
  836. (test '#() make-vector 0)
  837. (test '#() make-vector 0 'a)
  838. (SECTION 6 9)
  839. (test #t procedure? car)
  840. (test #f procedure? 'car)
  841. (test #t procedure? (lambda (x) (* x x)))
  842. (test #f procedure? '(lambda (x) (* x x)))
  843. (test #t call-with-current-continuation procedure?)
  844. (test 7 apply + (list 3 4))
  845. (test 7 apply (lambda (a b) (+ a b)) (list 3 4))
  846. (test 17 apply + 10 (list 3 4))
  847. (test '() apply list '())
  848. (define compose (lambda (f g) (lambda args (f (apply g args)))))
  849. (test 30 (compose sqt *) 12 75)
  850.  
  851. (test '(b e h) map cadr '((a b) (d e) (g h)))
  852. (test '(5 7 9) map + '(1 2 3) '(4 5 6))
  853. (test '#(0 1 4 9 16) 'for-each
  854.     (let ((v (make-vector 5)))
  855.         (for-each (lambda (i) (vector-set! v i (* i i)))
  856.             '(0 1 2 3 4))
  857.         v))
  858. (test -3 call-with-current-continuation
  859.         (lambda (exit)
  860.          (for-each (lambda (x) (if (negative? x) (exit x)))
  861.              '(54 0 37 -3 245 19))
  862.         #t))
  863. (define list-length
  864.  (lambda (obj)
  865.   (call-with-current-continuation
  866.    (lambda (return)
  867.     (letrec ((r (lambda (obj) (cond ((null? obj) 0)
  868.                 ((pair? obj) (+ (r (cdr obj)) 1))
  869.                 (else (return #f))))))
  870.     (r obj))))))
  871. (test 4 list-length '(1 2 3 4))
  872. (test #f list-length '(a b . c))
  873. (test '() map cadr '())
  874.  
  875. ;;; This tests full conformance of call-with-current-continuation.  It
  876. ;;; is a separate test because some schemes do not support call/cc
  877. ;;; other than escape procedures.  I am indebted to
  878. ;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
  879. ;;; code.  The function leaf-eq? compares the leaves of 2 arbitrary
  880. ;;; trees constructed of conses.  
  881. (define (next-leaf-generator obj eot)
  882.   (letrec ((return #f)
  883.        (cont (lambda (x)
  884.            (recur obj)
  885.            (set! cont (lambda (x) (return eot)))
  886.            (cont #f)))
  887.        (recur (lambda (obj)
  888.               (if (pair? obj)
  889.               (for-each recur obj)
  890.               (call-with-current-continuation
  891.                (lambda (c)
  892.                  (set! cont c)
  893.                  (return obj)))))))
  894.     (lambda () (call-with-current-continuation
  895.         (lambda (ret) (set! return ret) (cont #f))))))
  896. (define (leaf-eq? x y)
  897.   (let* ((eot (list 'eot))
  898.      (xf (next-leaf-generator x eot))
  899.      (yf (next-leaf-generator y eot)))
  900.     (letrec ((loop (lambda (x y)
  901.              (cond ((not (eq? x y)) #f)
  902.                ((eq? eot x) #t)
  903.                (else (loop (xf) (yf)))))))
  904.       (loop (xf) (yf)))))
  905. (define (test-cont)
  906.   (newline)
  907.   (display ";testing continuations; ")
  908.   (newline)
  909.   (SECTION 6 9)
  910.   (test #t leaf-eq? '(a (b (c))) '((a) b c))
  911.   (test #f leaf-eq? '(a (b (c))) '((a) b c d))
  912.   (report-errs))
  913.  
  914. ;;; Test Optional R4RS DELAY syntax and FORCE procedure
  915. (define (test-delay)
  916.   (newline)
  917.   (display ";testing DELAY and FORCE; ")
  918.   (newline)
  919.   (SECTION 6 9)
  920.   (test 3 'delay (force (delay (+ 1 2))))
  921.   (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
  922.             (list (force p) (force p))))
  923.   (test 2 'delay (letrec ((a-stream
  924.                (letrec ((next (lambda (n)
  925.                         (cons n (delay (next (+ n 1)))))))
  926.                  (next 0)))
  927.               (head car)
  928.               (tail (lambda (stream) (force (cdr stream)))))
  929.            (head (tail (tail a-stream)))))
  930.   (letrec ((count 0)
  931.        (p (delay (begin (set! count (+ count 1))
  932.                 (if (> count x)
  933.                 count
  934.                 (force p)))))
  935.        (x 5))
  936.     (test 6 force p)
  937.     (set! x 10)
  938.     (test 6 force p))
  939.   (test 3 'force
  940.     (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
  941.          (c #f))
  942.       (force p)))
  943.   (report-errs))
  944.  
  945. (SECTION 6 10 1)
  946. (test #t input-port? (current-input-port))
  947. (test #t output-port? (current-output-port))
  948. (test #t call-with-input-file "test.scm" input-port?)
  949. (define this-file (open-input-file "test.scm"))
  950. (test #t input-port? this-file)
  951. (SECTION 6 10 2)
  952. (test #\; peek-char this-file)
  953. (test #\; read-char this-file)
  954. (test '(define cur-section '()) read this-file)
  955. (test #\( peek-char this-file)
  956. (test '(define errs '()) read this-file)
  957. (close-input-port this-file)
  958. (close-input-port this-file)
  959. (define (check-test-file name)
  960.   (define test-file (open-input-file name))
  961.   (test #t 'input-port?
  962.     (call-with-input-file
  963.         name
  964.       (lambda (test-file)
  965.         (test load-test-obj read test-file)
  966.         (test #t eof-object? (peek-char test-file))
  967.         (test #t eof-object? (read-char test-file))
  968.         (input-port? test-file))))
  969.   (test #\; read-char test-file)
  970.   (test display-test-obj read test-file)
  971.   (test load-test-obj read test-file)
  972.   (close-input-port test-file))
  973. (SECTION 6 10 3)
  974. (define write-test-obj
  975.   '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
  976. (define display-test-obj
  977.   '(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
  978. (define load-test-obj
  979.   (list 'define 'foo (list 'quote write-test-obj)))
  980. (test #t call-with-output-file
  981.       "tmp1"
  982.       (lambda (test-file)
  983.     (write-char #\; test-file)
  984.     (display write-test-obj test-file)
  985.     (newline test-file)
  986.     (write load-test-obj test-file)
  987.     (output-port? test-file)))
  988. (check-test-file "tmp1")
  989.  
  990. (define test-file (open-output-file "tmp2"))
  991. (write-char #\; test-file)
  992. (display write-test-obj test-file)
  993. (newline test-file)
  994. (write load-test-obj test-file)
  995. (test #t output-port? test-file)
  996. (close-output-port test-file)
  997. (check-test-file "tmp2")
  998. (define (test-sc4)
  999.   (newline)
  1000.   (display ";testing scheme 4 functions; ")
  1001.   (newline)
  1002.   (SECTION 6 7)
  1003.   (test '(#\P #\space #\l) string->list "P l")
  1004.   (test '() string->list "")
  1005.   (test "1\\\"" list->string '(#\1 #\\ #\"))
  1006.   (test "" list->string '())
  1007.   (SECTION 6 8)
  1008.   (test '(dah dah didah) vector->list '#(dah dah didah))
  1009.   (test '() vector->list '#())
  1010.   (test '#(dididit dah) list->vector '(dididit dah))
  1011.   (test '#() list->vector '())
  1012.   (SECTION 6 10 4)
  1013.   (load "tmp1")
  1014.   (test write-test-obj 'load foo)
  1015.   (report-errs))
  1016.  
  1017. (report-errs)
  1018. (if (and (string->number "0.0") (inexact? (string->number "0.0")))
  1019.     (test-inexact))
  1020.  
  1021. (let ((n (string->number "281474976710655")))
  1022.   (if (and n (exact? n))
  1023.       (test-bignum)))
  1024. (newline)
  1025. (test-cont)
  1026. (newline)
  1027. (test-sc4)
  1028. (newline)
  1029. (test-delay)
  1030. (newline)
  1031. "last item in file"
  1032.